perm filename CYCOMB[1,LMM]2 blob
sn#033092 filedate 1973-03-28 generic text, type T, neo UTF8
(DE MOLECULES (CL U)
(IF (ZEROP U) THEN (GENMOL CL)
ELSE
(FOR NEW SAP IN (SUPERATOMPARTITIONS CL U)
FOR NEW S IN (SUPERATOMS (SUPERATOMPARTS SAP))
NCONC FIRST NIL (GENMOL (APPEND (CLCREATE S)
(REMAININGATOMS SAP)))))))))
)))))))))))))))))
(DE SUPERATOMPARTITIONS (CL U)
(PROG (CL1 SZ)
(SETQ CL1 (FOR NEW PR IN CL WHEN (EQUAL (VALENCE (CAR PR)) 1)
LIST PR))
(SETQ CL (CLDIFF CL CL1))
(RETURN
(FOR NEW PARTSIZE := (2 (SETQ SZ (CLCOUNT CL)))
FOR NEW VHAT IN (CLPARTS CL PARTSIZE)
AS NEW REMATS IS (APPEND CL1 (CLDIFF CL VHAT))
FOR NEW #PARTS := (1 (QUOTIENT PARTSIZE 2))
FOR NEW PARTITION IN (CLPARTITIONSN VHAT #PARTS 2 9999999)
AS NEW VI IS (CLCREATE PARTITION)
AS NEW MXUI IS (MAXUNSATL VI)
WHEN MXUI FOR NEW UI IN
(NUMPARTITIONS* U 1 MXUI (MAPCAR @CDR VI))
XLIST
(SUPERATOMPARTITION
REMAININGATOMS = REMATS SUPERATOMPARTS =
(PROG (CVI CVN M VI2 CUI VI3)
(SETQ VI3 VI)
VILOOP (IF (NULL VI3)
THEN (RETURN VI2))
(SETQ CVI (CAAR VI3))
(SETQ CVN (CDAR VI3))
(SETQ VI3 (CDR VI3))
LOOPM (SETQ M 0)
LOOPCVN (SETQ M (ADD1 M))
(SETQ CVN (SUB1 CVN))
(SETQ CUI (CAR UI))
(SETQ UI (CDR UI))
(IF (AND (NOT (ZEROP CVN))
(EQUAL CUI (CAR UI)))
THEN (GO LOOPCVN))
(SETQ VI2 (CONS (CONS (CONS CUI CVI)
M)
VI2))
(IF (ZEROP CVN)
THEN (GO VILOOP)
ELSE (GO LOOPM))))))))))))))))
)))))))))))))))))
(DE
MAXUNSATL
(PC)
(FOR NEW PART-NUM IN PC LIST
(PROG (N TD M)
(SETQ N(SETQ TD(SETQ M 0)))
(FOR NEW PR IN (CAR PART-NUM)
DO
(SETQ N (PLUS N (CDR PR)))
(SETQ TD (PLUS TD (TIMES (CDR PR)
(VALENCE (CAR PR)))))
(SETQ M (MAX M (VALENCE (CAR PR)))))
(RETURN (FIX (TIMES 0.5
(PLUS 2 TD (TIMES -2 N)
(MIN -1 (DIFFERENCE
TD
(TWICE M))))))))))
)))))))))))))))))
(DE SUPERATOMS (UCL-COMP)
(GROUPRADS (FOR NEW UCLN IN UCL-COMP LIST
(CONS (RINGS (CAAR UCLN)
(CDAR UCLN))
(CDR UCLN)))))
)))))))))))))))))
(DE COMPUTEFV (U CL)
(PROG (TD N)
(SETQ TD(SETQ N 0))
(FOR NEW PR IN CL DO (SETQ
TD
(PLUS (TIMES (VALENCE (CAR PR))
(CDR PR))
TD))
(SETQ N (PLUS (CDR PR)
N)))
(RETURN (PLUS 2 TD (TIMES -2 (PLUS N U))))))
)))))))))))))))))
(DE CLBYVALENCE (CL)
(PROG2 (SETQ CL (GROUPBY (FUNCTION (LAMBDA (PR)
(VALENCE (CAR PR))))
CL))
(FOR NEW I := (2 (MAXLIST (MAPCAR (QUOTE CAR) CL)))
LIST
(LMASSOC I CL NIL))))
)))))))))))))))))
(DE RINGS (U CL)
(PROG (FV)
(SETQ FV (COMPUTEFV U CL))
(SETQ CL (CLBYVALENCE CL))
(RETURN (FOR NEW SKELETON IN (RINGSKELETONS
FV
(MAPCAR (QUOTE CLCOUNT) CL))
NCONC FIRST NIL (STRUCTURESWITHATOMS CL
SKELETON)))))
)))))))))))))))))
(DE FVPARTITIONS (FV VL)
(FOR NEW FVP IN (FVPARTITION1 FV (CDR VL)
1)
AS NEW FVR IS (ROWS FVP)
XLIST
(FVPARTITION FVR = FVR NEWVL =
(FOR NEW ROW IN FVR AS NEW COL IN (CONS NIL FVP)
AS NEW V IN VL LIST
(PLUS V (PLUSLIST ROW)
(MINUS (PLUSLIST COL)))))))
)))))))))))))))))
(DE RINGSKELETONS (FV VL)
(FOR NEW FVPART IN (FVPARTITIONS FV VL)
FOR NEW STRUC IN (NOFV-RINGS (NEWVL FVPART))
NCONC FIRST NIL (ATTACHFVS (FVR FVPART)
STRUC)))
)))))))))))))))))
(DE NOFV-RINGS (VL)
(PROG (MNLPS MXLPS SUMREST)
(SETQ SUMREST (PLUSLIST (CDR VL)))
(IF (ZEROP SUMREST)
THEN
(RETURN (SINGLERINGS (CAR VL)))
ELSEIF
(EQUAL SUMREST 1)
THEN
(RETURN (DAISIES VL)))
(SETQ MNLPS (MINLOOPS VL))
(SETQ MXLPS (MAXLOOPS VL))
(RETURN (FOR NEW P := (MNLPS MXLPS)
NCONC FIRST NIL (KLOOPEDRINGS P VL)))))
)))))))))))))))))
(DE DAISIES (VL)
(FOR NEW P IN (NUMPARTITIONS
(CAR VL)
(QUOTIENT (FOR NEW X IN (CDR VL)
AS NEW I := (3 99999)
UNTIL
(NOT (ZEROP X))
PROG2 I)
2)
1 99999999)
NCONC FIRST NIL (DAISY (CLCREATE P))))
)))))))))))))))))
(DE NOLOOPEDRINGS (VL)
(IF (ZEROP (CAR VL))
THEN
(CATALOG (CDR VL))
ELSE
(PROG (BP)
(SETQ BP (BIVALENTPARTITIONS VL))
(RETURN (FOR NEW S IN (CATALOG (CDR VL))
FOR NEW P IN BP NCONC FIRST NIL
(ATTACHBIVALENTS (CLCREATE P)
S))))))
)))))))))))))))))
(DE ROWS (LL)
(IF (NOT LL)
THEN
(QUOTE (NIL))
ELSE
(CONS (CARLIST LL) (ROWS (CDRLIST (CDR LL)))
)))))))))))))))))
(DE BIVALENTPARTITIONS (VL)
(NUMPARTITIONS (CAR VL)
(QUOTIENT (FOR NEW I := (3 9999)
AS NEW X IN (CDR VL)
PLUS
(TIMES I X))
2)
0
(CAR VL)))
)))))))))))))))))
(COMMENT THESE FNS KNOW WHAT STRUCTURES ARE )
(DE FREEVALENCESIZE (S)
(IF (STRUCTURE? S)
THEN
(FOR NEW X IN (CTABLE S)
FOR NEW Y IN (NBRS X)
WHEN
(EQ Y (QUOTE FV))
PLUS 1)
ELSEIF
(STRUCFORM? S)
THEN
(IF (EQ (CAR (FORM S))
(QUOTE ATTACHFVS))
THEN
(FOR NEW FVL IN (CADR (FORM S))
FOR NEW X IN FVL AS NEW I := (1 999999)
PLUS
(TIMES I X))
ELSE
(FREEVALENCESIZE (CADDR (FORM S))))))
)))))))))))))))))
(DE NODES (STRUC)
(MAPCAR (FUNCTION (LAMBDA (X)
(NODENUM X)))
(CTABLE STRUC)))
)))))))))))))))))
(DE COLLECTFV (S)
(FOR NEW CT IN (CTABLE S)
FOR NEW X IN (NBRS CT)
WHEN
(EQ X (QUOTE FV))
XLIST
(NODENUM CT)))
)))))))))))))))))
(DE TRIMZEROS (L)
(PROG (N)
(RETURN (IF (NULL L)
THEN NIL ELSEIF (ZEROP (SETQ N (PLUSLIST L)))
THEN NIL ELSE (CONS (CAR L)
(TRIMZEROS (CDR L)))))))
)))))))))))))))))
(DE CATALOG (L)
(IF (AND (EQUAL (PLUSLIST (SETQ L (TRIMZEROS L)))
2)
(EQUAL (CAR (LAST L))
2))
THEN
(LIST (STRUCWITH2NODES (PLUS 2 (LENGTH L))))
ELSE
(CATALOG3 L)))
)))))))))))))))))
(DE STRUCWITH2NODES (N)
(STRUCTURE UGRAPH = (CONS (QUOTE MBONDS)
N)
CTABLE = (LIST (CTENTRY NODENUM = 1 NBRS =
(FOR NEW I := (1 N)
XLIST 2))
(CTENTRY NODENUM = 2 NBRS =
(FOR NEW I := (1 N)
XLIST 1)))
LASTNODE# = 2))
)))))))))))))))))
(DE CATALOG3 (TVL)
(PROG (C)
(COND ((NOT (ZEROP (PLUSLIST (CDR TVL))))
NIL)
(T (SETQ C (NTH CATALOG-LIST (QUOTIENT (CAR TVL)
2)))))
(RETURN (IF (AND C (CAR C))
THEN
(CAR C)
ELSE
(LIST (STRUCFORM FORM = (CONS (QUOTE CATALOG)
TVL)))))))
)))))))))))))))))
(DE DAISY (PART)
(PROG (S C)
(SETQ LASTNODE 1)
(SETQ S (STRUCTURE UGRAPH= (CONS (QUOTE DAISY)
PART)
CTABLE = (LIST (CTENTRY NODENUM =
LASTNODE))
LASTNODE# = LASTNODE))
(SETQ C LASTNODE)
(RETURN (LIST (FOR NEW PAIR IN PART FOR NEW I :=
(1 (CDR PAIR))
PROG2
(SETQ S (PUTBIVN S C (CAR PAIR))))))))
)))))))))))))))))
(DE SINGLERING (N)
(PROG (S)
(SETQ LASTNODE 0)
(SETQ S (BIVCHAIN N))
(CONNECT (CAR (CTABLE S))
(CAR (LAST(CTABLE S))))
(RETURN (STRUCTURE FROM S UGRAPH = (CONS (QUOTE SINGLERING)
N)))))
)))))))))))))))))
(DE BIVCHAIN (N)
(FOR NEW I := (1 N)
AS NEW X IS X PROG2 (SETQ X (PUTNEWNODE X))))
)))))))))))))))))
(DE CONNECT (X Y)
(PROG NIL (REPLACE (NBRS X)
(CONS (NODENUM Y)
(NBRS X)))
(COND ((NOT (EQ X Y))
(REPLACE (NBRS Y)
(CONS (NODENUM X)
(NBRS Y)))))))
)))))))))))))))))
(DE COPYSTRUC (S)
(PROG2 (SETQ LASTNODE (LASTNODE# S))
(COPY S)))
)))))))))))))))))
(DE DISCONNECT (X Y)
(PROG NIL (REPLACE (NBRS X)
(DELETE (NODENUM Y)
(NBRS X)))
(REPLACE (NBRS Y)
(DELETE (NODENUM X)
(NBRS Y)))))
)))))))))))))))))
(DE FINDCTE (N LST)
(IF (NUMBERP N)
THEN
(IF (EQ (ID LST)
(QUOTE STRUC))
THEN
(SETQ LST (CTABLE LST))
ELSE NIL)
(FOR NEW L IN LST WHEN (EQUAL (NODENUM L)
N)
DO
(RETURN L))
ELSEIF
(NUMBERP LST)
THEN
(FINDCTE LST N)
ELSE
(ERROR (QUOTE (BAD ARGUMENTS TO FINDCTE)))))
)))))))))))))))))
(DE FIRSTOFNODES (X)
(CAR (NODES X)))
)))))))))))))))))
(DE LASTOFNODES (X)
(CAR (LAST (NODES X)))))
)))))))))))))))))
(DE LISTBYVALENCE (S)
(PROG (M V)
(SETQ M (LENGTH (NODES S)))
(RETURN (FOR NEW I := (2 999)
WHILE
(GREATERP M 0)
LIST
(SETQ V (VALENCETYPE S I))
(SETQ M (DIFFERENCE M (LENGTH V)))
V))))
)))))))))))))))))
(DE PUTFVN (S N J)
(PROG NIL (SETQ N (FINDCTE N (CTABLE S)))
(REPLACE (NBRS N)
(NCONC (NBRS N)
(FOR NEW I := (1 J)
XLIST
(QUOTE FV))))
(RETURN S)))
)))))))))))))))))
(DE PUTFVS (S FVP)
(FOR NEW NI IN FVP FOR NEW NIJ IN NI AS NEW J := (1 10)
FOR NEW NODE IN NIJ PROG2 (SETQ S (PUTFVN S NODE J))))
)))))))))))))))))
(DE PUTNEWNODE (STRUC)
(IF STRUC THEN (PROG2 (SETQ LASTNODE (ADD1 (LASTNODE# STRUC)))
(STRUCTURE FROM STRUC CTABLE =
(PUTNEWNODEINCT (CTENTRY NODENUM
=
LASTNODE)
(CTABLE OF STRUC)
)
LASTNODE# = LASTNODE))
ELSE
(PROG2 (SETQ LASTNODE (ADD1 LASTNODE))
(STRUCTURE CTABLE = (LIST (CTENTRY NODENUM = LASTNODE))
LASTNODE# = LASTNODE))))
)))))))))))))))))
(DE PUTNEWNODEINCT (X Y)
(PROG (Z)
(SETQ Z (CAR Y))
(REPLACE (NBRS OF Z)
(CONS (NODENUM X)
(NBRS Z)))
(REPLACE (NBRS OF X)
(CONS (NODENUM Z)
(NBRS X)))
(RETURN (CONS X Y))))
)))))))))))))))))
(DE NODEVALENCE (NODE)
(IF (NULL NODE)
THEN
(ERROR (QUOTE (NULL NODE GIVEN TO NODEVALENCE)))
ELSEIF
(EQ (ID NODE)
(QUOTE CTE))
THEN
(LENGTH (NBRS NODE))
ELSE
(NODEVALENCE (FINDCTE (CAR NODE)
(CDR NODE)))))
)))))))))))))))))
(DE VALENCETYPE (S I)
(FOR NEW NODE IN (CTABLE S)
WHEN
(EQUAL I (NODEVALENCE NODE))
XLIST
(NODENUM NODE)))
)))))))))))))))))
(DE SINGLERINGS (N)
(LIST (SINGLERING N)))
)))))))))))))))))
(DE INSERTMARKERS (STRUC CLL L)
(PROG NIL
(FOR NEW CL IN CLL AS NEW NLL IN L FOR NEW PAIR IN CL AS
NEW NL IN NLL FOR NEW N IN NL DO
(REPLACE (ATOMTYPE (MARKERS (FINDCTE N STRUC)))
(CAR PAIR)))
(RETURN STRUC)))
)))))))))))))))))
(DE DELETE (I L)
(COND ((NULL L)
NIL)
((EQUAL (CAR L)
I)
(CDR L))
(T (CONS (CAR L)
(DELETE I (CDR L))))))
)))))))))))))))))